<%
Private Const INIT_SIZE = 1024
Private Const INIT_GAP_SIZE = 128
Class ArrayElement
  Public IsTaken
  Public Value
  Public Key
End Class

Class HashTable
  '私有变量
  Private mCount
  Private mCurrentSize
  Private mArray
  Private mSize
  Private mGapSize
  
  '类的初始化和清空
  
  Private Sub Class_Initialize()
    mCount = 0 : mCurrentSize = 0
    Redim mArray(0)
    resizeArray INIT_SIZE
    Me.GapSize = INIT_GAP_SIZE
  End Sub
  
  Private Sub Class_Terminate()

  End Sub
  
  '私有方法
  
  Private Sub resizeArray(ByVal newSize)
    Dim i, mOldSize
    Dim element
    'Stop
    mOldSize = UBound(mArray)
    If mCount > 0 Then
      ReDim Preserve mArray(newSize)
    Else
      ReDim Preserve mArray(newSize)
    End If
    For i = mOldSize + 1 To newSize
      Set element = New ArrayElement
      element.IsTaken = False
      Set mArray(i) = element
    Next
    mCurrentSize = newSize
  End Sub
  
  Private Sub expandArray()
    mCurrentSize = mCurrentSize + mGapSize
    resizeArray mCurrentSize
  End Sub

  Private Function findIndex(ByVal keyword)
    Dim index, startIndex
    
    index = calcInitIndex(keyword)
    startIndex = index
    
    Do While True
      If VarType(mArray(index)) > 0 Then
        If mArray(index).IsTaken = True And mArray(index).Key = keyword Then
          findIndex = index
          Exit Function
        Else
          index = (index + 1) Mod mCurrentSize
          If index = 0 Then index = index + 1
          If startIndex = index Then
            findIndex = -1
            Exit Function
          End If
        End If
      Else
        index = (index + 1) Mod mCurrentSize
        If index = 0 Then index = index + 1
        If startIndex = index Then
          findIndex = -1
          Exit Function
        End If
      End If
    Loop
  End Function

  Private Function findFreeIndex(ByVal keyword)
    Dim index, startIndex
    index = calcInitIndex(keyword)
    
    startIndex = index
    Do While True
      If VarType(mArray(index)) > 0 Then
        If mArray(index).Key = keyword Or mArray(index).IsTaken = False Then
          findFreeIndex = index
          Exit Function
        Else
          index = (index + 1) Mod mCurrentSize
          If index = 0 Then index = index + 1
          If startIndex = index Then
            findFreeIndex = -1
            Exit Function
          End If
        End If
      Else
        findFreeIndex = index
        Exit Function
      End If
    Loop
  End Function

  Private Function calcInitIndex(ByVal keyword)
    Dim index, i
    Dim bytes
    bytes = stringToByteArray(keyword)
    For i = 1 To UBound(bytes)
      index = index + bytes(i)
      If index > mCount Then
        index = index Mod mCurrentSize
      End If
    Next
    If index = 0 Then index = index + 1
    calcInitIndex = index
  End Function
  
  Private Function stringToByteArray(Byval s)
    Dim i, byteArray()
    Redim byteArray(Len(s))
    For i = 1 To Len(s)
      byteArray(i) = Asc(Mid(s,i,1))
    Next
    stringToByteArray = byteArray
  End Function

  Private Function getValue(ByVal Key)
    Dim index
    index = findIndex(Key)
    If index > 0 Then
      getValue = mArray(index).Value
    Else
      Err.Raise vbObjectError + 1012, ,"[SunSoft]未指定默认值"
    End If
  End Function

  Private Sub addOrUpdate(ByVal Key, ByVal Value)
    Dim index
    Dim item
    '寻找是否现存此关键词
    index = findIndex(Key)
    '如果没有，则寻找一个现存空位
    If index <= 0 Then
      index = findFreeIndex(Key)
      mCount = mCount + 1
    End If
    '如果没找到
    If index < 0 Then
      '扩大空间
      Call expandArray
      '再挑一个位置
      index = findFreeIndex(Key)
    End If
    
    Set item = New ArrayElement
    item.IsTaken = True
    item.Key = Key
    item.Value = Value
    Set mArray(index) = Nothing
    Set mArray(index) = item
  End Sub

  Public Function UTF8_URLEncoding(ByVal szInput)
    Dim wch, uch, szRet
    Dim X
    Dim nAsc, nAsc2, nAsc3
    wch = "" : uch = "" : szRet = ""
    X = 0
    nAsc = 0 : nAsc2 = 0 : nAsc3 = 0
    If szInput = "" Then
      UTF8_URLEncoding = szInput
      Exit Function
    End If
    For X = 1 To Len(szInput)
      wch = Mid(szInput, X, 1)
      nAsc = AscW(wch)
      
      If nAsc < 0 Then nAsc = nAsc + 65536
      
      If (nAsc And &HFF80) = 0 Then
        szRet = szRet & wch
      Else
        If (nAsc And &HF000) = 0 Then
          uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
          szRet = szRet & uch
        Else
          uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
          Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
          Hex(nAsc And &H3F Or &H80)
          szRet = szRet & uch
        End If
      End If
    Next
    UTF8_URLEncoding = szRet
  End Function

  Public Function UTF8_UrlDecode(ByVal URL)
    Dim SingleWord, UtfBStr   ''中文字的Unicode码(2字节)
    Dim UtfB    ''Utf-8单个字节
    Dim UtfB1, UtfB2, UtfB3 ''Utf-8码的三个字节
    Dim i, OriginUrl
    SingleWord = "" : UtfBStr = ""
    UtfB = 0
    UtfB1 = 0 : UtfB2 = 0 : UtfB3 = 0
    i = 0 : OriginUrl = ""

    For i = 1 To Len(URL)
      SingleWord = Mid(URL, i, 1)
      Select Case SingleWord
        Case "+"
          OriginUrl = OriginUrl & " "
        Case "%"
          UtfBStr = Mid(URL, i + 1, 2)
          UtfB = CInt("&H" & UtfBStr)
          If UtfB < 128 Then
            i = i + 2
            OriginUrl = OriginUrl & ChrW(UtfB)
          Else
            UtfB1 = CLng(UtfB And &HF) * &H1000   ''取第1个Utf-8字节的二进制后4位
            UtfB2 = (CInt("&H" & Mid(URL, i + 4, 2)) And &H3F) * &H40      ''取第2个Utf-8字节的二进制后6位
            UtfB3 = CInt("&H" & Mid(URL, i + 7, 2)) And &H3F      ''取第3个Utf-8字节的二进制后6位
            OriginUrl = OriginUrl & ChrW(UtfB1 Or UtfB2 Or UtfB3)
            i = i + 8
          End If
        Case Else    ''Ascii码
          OriginUrl = OriginUrl & SingleWord
      End Select
    Next
    UTF8_UrlDecode = OriginUrl
  End Function
'  Public Sub SaveToFile(ByVal filePath As String)
'    On Error Resume Next
'    Dim fileNum As Long, Data As DataPacker
'    Data.arrays = mArray
'    fileNum = FreeFile
'    Kill filePath
'    Open filePath For Binary As #fileNum
'      Put #fileNum, , Data
'    Close #fileNum
'  End Sub

'Public Sub LoadFromFile(ByVal filePath As String)
'  On Error Resume Next
'  Dim fileNum As Long, Data As DataPacker, i As Long
'  fileNum = FreeFile
'  Open filePath For Binary As #fileNum
'    Get #fileNum, , Data
'  Close #fileNum
'  For i = 0 To UBound(Data.arrays)
'    If Data.arrays(i).IsTaken = True Then
'      Item(Data.arrays(i).key) = Data.arrays(i).Value
'    End If
'  Next i
'End Sub

  Public Function ExistKey(ByVal KeyName)
    ExistKey = findIndex(KeyName) > 0
  End Function

  '公有属性

  Public Property Get GapSize()
    GapSize = mGapSize
  End Property

  Public Property Let GapSize(ByVal newValue)
    If mCount > 0 Then
      Err.Raise vbObjectError + 1000, ,"[SunSoft]已经有数据，容量的增量不得修改"
    End If
    If newValue <= 0 Then
      Err.Raise vbObjectError + 1001, ,"[SunSoft]容量的增量不得为负数"
    End If
    mGapSize = newValue
  End Property
  
  Public Property Get Item(Byval Key)
    Dim index
    index = 0
    index = findIndex(Key)
    If index = -1 Then
      Item = Empty
    Else
      Item = getValue(Key)
    End If
  End Property
  
  Public Property Let Item(ByVal Key, ByVal Value)
    Dim index

    index = findIndex(Key)

    If index > 0 Then
      mArray(index).IsTaken = True
      mArray(index).key = key
      mArray(index).Value = Value
      Exit Property
    End If

    index = findFreeIndex(Key)
    If index < 0 Then
      Call expandArray
      index = findFreeIndex(Key)
    End If
    mCount = mCount + 1
    mArray(index).IsTaken = True
    mArray(index).Key = Key
    mArray(index).Value = Value
  End Property
  
  Public Property Get Count()
    Count = mCount
  End Property
  
  '公有方法

  Public Sub Add(ByVal Key, ByVal Value)
    If KeyExist(Key) Then
      Err.Raise vbObjectError + 1011, ,"[SunSoft]键重复"
    Else
      addOrUpdate Key, Value
    End If
  End Sub
  
  Public Function TryGet(ByVal Key,ByVal DefValue)
    On Error Resume Next
    Dim Value
    Value = getValue(Key)
    If Err.Number > 0 Then
      TryGet = DefValue
    Else
      TryGet = Value
    End If
    Err.Clear
  End Function
  
  Public Function KeyExist(ByVal Key)
    If findIndex(Key) < 0 Then
      KeyExist = False
    Else
      KeyExist = True
    End If
  End Function

  Public Function ToURLParams(Byval Params())
    Dim param
    Dim encodedURL
    Dim m_Key, m_Value
    Dim i

    encodedURL = ""
    m_Key = "" : m_Value = ""
    i = 0

    If UBound(Params) = -1 Then
      For i = 1 To UBound(mArray)
        If mArray(i).IsTaken = True Then
          m_Key = mArray(i).key
          m_Value = mArray(i).Value
          If encodedURL = "" Then
            encodedURL = m_Key & "=" & UTF8_URLEncoding(m_Value)
          Else
            encodedURL = encodedURL & "&" & m_Key & "=" & UTF8_URLEncoding(m_Value)
          End If
        End If
      Next
    Else
      For Each param In Params
        If encodedURL = "" Then
          encodedURL = param & "=" & UTF8_URLEncoding(Item(param))
        Else
          encodedURL = encodedURL & "&" & param & "=" & UTF8_URLEncoding(Item(param))
        End If
      Next
    End If

    ToURLParams = encodedURL
  End Function

  Public Function ToArray()
    Dim dataArr(), i, counter

    Dim m_Key, m_Value
    i = 0 : counter = 0
    m_Key = "" : m_Value = ""
    ReDim dataArr(Count - 1, 1)
    For i = 1 To UBound(mArray)
      If mArray(i).IsTaken = True Then
        m_Key = mArray(i).key
        m_Value = mArray(i).Value
        dataArr(counter, 0) = m_Key
        dataArr(counter, 1) = m_Value
        counter = counter + 1
      End If
    Next
    ToArray = dataArr
  End Function

  Public Function Keys()
    Dim m_Key, m_Keys
    Dim i

    m_Key = "" : Set m_Keys = New CList
    i = 0
    For i = 1 To UBound(mArray)
      If mArray(i).IsTaken = True Then
        m_Key = mArray(i).key
        m_Keys.Add "`" & m_Key & "`"
      End If
    Next
    Set Keys = m_Keys
  End Function

  Public Function Values()' As CList
    Dim m_Value
    Dim m_Values
    Dim i

    Set m_Values = New CList
    i = 0
    For i = 1 To UBound(mArray)
      If mArray(i).IsTaken = True Then
        m_Value = mArray(i).Value
        If VarType(m_Value) = vbString Then
          m_Values.Add m_Value
        ElseIf VarType(m_Value) = vbDate Then
          m_Values.Add "'#" & Format(m_Value, "yyyy-mm-dd hh:mm:ss") & "#'"
        Else
          m_Values.Add m_Value
        End If
      End If
    Next
    Set Values = m_Values
  End Function
End Class
%>